home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / prompt.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  13KB  |  404 lines
  1. ;;;; prompt.jl -- Prompt in a buffer with completion
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defvar prompt-keymap (make-keylist))
  21.  
  22. (defvar prompt-buffer-list '()
  23.   "Stack of buffers which can be used for prompts.")
  24.  
  25. (bind-keys prompt-keymap
  26.   "TAB"        'prompt-complete-word
  27.   "RET"        'prompt-enter-line
  28.   "LMB-CLICK2"    'prompt-select-completion
  29.   "RMB-CLICK1"    'prompt-complete-word
  30.   "Meta-?"    'prompt-print-word-completions
  31.   "Ctrl-g"    'prompt-cancel)
  32.  
  33.  
  34. ;; Configuration variables
  35.  
  36. (defvar prompt-completion-function nil
  37.   "Optional function taking one argument, the string to be completed. It
  38. should return a list of all matches.")
  39.  
  40. (defvar prompt-validate-function nil
  41.   "Optional function taking one argument, the string which has been entered.
  42. Should return non-nil when this string may be accepted (and therefore the
  43. prompt will end). If it returns the symbol t the string is returned as-is,
  44. if some other non-nil value is returned *that* is the value returned by
  45. the prompt.")
  46.  
  47. (defconst prompt-def-regexps ["." "^|$"]
  48.   "Default value of `prompt-word-regexps'")
  49.  
  50. (defvar prompt-word-regexps prompt-def-regexps
  51.   "Vector of two regexps; the values of `word-regexp' and `word-not-regexp'
  52. for the prompt.")
  53.  
  54. (defvar prompt-list nil
  55.   "Used by the `prompt-complete-from-list' and `prompt-validate-from-list'
  56. to supply possible completions.")
  57.  
  58. (defvar prompt-symbol-predicate nil
  59.   "Predicate used when prompting for symbols.")
  60.  
  61. (defvar amiga-use-file-req-p t
  62.   "*AMIGA ONLY*
  63. When non-nil the normal ASL file requester is used when file names are
  64. prompted for.")
  65.  
  66.  
  67. (defvar prompt-buffer nil
  68.   "The buffer being used for the prompt.")
  69.  
  70. (defvar prompt-completions-pos nil
  71.   "Position at which the list of completions should be printed.")
  72.  
  73.  
  74. ;; Main entrypoint
  75.  
  76. (defun prompt2 (&optional title start)
  77.   "Prompts for a string using completion. TITLE is the optional title to
  78. print in the buffer, START the original contents of the buffer.
  79. The string entered is returned, or nil if the prompt is cancelled (by Ctrl-g)."
  80.   (let*
  81.       (prompt-buffer
  82.        prompt-line-pos
  83.        prompt-completions-pos
  84.        result)
  85.     (if prompt-buffer-list
  86.     (setq prompt-buffer (car prompt-buffer-list)
  87.           prompt-buffer-list (cdr prompt-buffer-list))
  88.       (setq prompt-buffer (make-buffer "*prompt*")))
  89.     (setq buffer-list (cons prompt-buffer buffer-list))
  90.     (set-buffer-special prompt-buffer t)
  91.     (with-buffer prompt-buffer
  92.       (setq word-regexp (aref prompt-word-regexps 0) 
  93.         word-not-regexp (aref prompt-word-regexps 1))
  94.       (if (stringp title)
  95.       (insert title)
  96.     (insert "Enter string:"))
  97.       (if (stringp start)
  98.       (format (current-buffer) "\n\n%s\n\n" start)
  99.     (insert "\n\n\n\n"))
  100.       (insert "::Completions::\n")
  101.       (setq prompt-completions-pos (cursor-pos))
  102.       (goto-char (line-end (prev-line 3)))
  103.       (setq keymap-path '(prompt-keymap global-keymap)
  104.         buffer-undo-list nil
  105.         result (catch 'prompt (recursive-edit))
  106.         buffer-list (delq prompt-buffer buffer-list)))
  107.     (clear-buffer prompt-buffer)
  108.     (setq prompt-buffer-list (cons prompt-buffer prompt-buffer-list))
  109.     result))
  110.  
  111.  
  112. ;; Subroutines
  113.  
  114. (defun prompt-enter-line (&optional whole-line)
  115.   (interactive)
  116.   (let*
  117.       ((pos (if (and (> (cursor-pos) prompt-completions-pos)
  118.              whole-line)
  119.         (line-end)
  120.           (cursor-pos)))
  121.        (line (copy-area (line-start) pos)))
  122.     (if (or (not prompt-validate-function)
  123.         (let
  124.         ((res (funcall prompt-validate-function line)))
  125.           (when (and res (not (eq res t)))
  126.         (setq line res))
  127.           res))
  128.     (throw 'prompt line)
  129.       (beep))))
  130.  
  131. (defun prompt-select-completion ()
  132.   (interactive)
  133.   (goto-char (mouse-pos))
  134.   (prompt-enter-line t))
  135.  
  136. ;; Returns the number of completions found.
  137. (defun prompt-complete-word ()
  138.   (interactive)
  139.   (if (not prompt-completion-function)
  140.       (progn
  141.     (message "No completion in this prompt!")
  142.     0)
  143.     (let*
  144.     ((word-pos (or (word-start (left-char))
  145.                (line-start)))
  146.      (word (copy-area word-pos (cursor-pos)))
  147.      (comp-list (funcall prompt-completion-function word))
  148.      (num-found (length comp-list))
  149.      (buffer-record-undo nil))
  150.       (cond
  151.        ((= num-found 0)
  152.     (delete-area prompt-completions-pos (buffer-end))
  153.     (message "No completions."))
  154.        ((= num-found 1)
  155.     (goto-char (replace-string word (car comp-list) word-pos))
  156.     (delete-area prompt-completions-pos (buffer-end))
  157.     (message "Unique completion."))
  158.        (t
  159.     (prompt-print-completions comp-list)
  160.     (when (not (string-head-eq (car comp-list) word))
  161.       ;; Completions don't match their source at all.
  162.       (delete-area word-pos (cursor-pos))
  163.       (setq word ""))
  164.     (goto-char (replace-string word
  165.                    (make-completion-string word comp-list)
  166.                    word-pos))
  167.     (format t "%d completions." num-found)))
  168.       num-found)))
  169.  
  170. (defun prompt-print-completions (comp-list)
  171.   (let*
  172.       ((ipos (copy-pos prompt-completions-pos))
  173.        ;; Don't want to record undo information for the completion list
  174.        (buffer-record-undo nil))
  175.     (delete-area ipos (buffer-end))
  176.     (insert "\n" ipos)
  177.     (while (consp comp-list)
  178.       (format (cons (current-buffer) ipos) "%s\n" (car comp-list))
  179.       (setq comp-list (cdr comp-list)))))
  180.  
  181. (defun prompt-print-word-completions ()
  182.   (interactive)
  183.   (prompt-print-completions
  184.    (funcall prompt-comp-func
  185.         (copy-area (or (word-start (left-char))
  186.                (line-start))
  187.                (cursor-pos)))))
  188.  
  189. (defun prompt-cancel ()
  190.   (interactive)
  191.   (message "Quit!")
  192.   (throw 'prompt nil))
  193.  
  194.  
  195. ;; Various completion/validation functions
  196.  
  197. (defun prompt-complete-symbol (word)
  198.   (mapcar 'symbol-name (apropos (concat ?^ word) prompt-symbol-predicate)))
  199.  
  200. (defun prompt-validate-symbol (name)
  201.   (and (find-symbol name)
  202.        (or (not prompt-symbol-predicate)
  203.        (funcall prompt-symbol-predicate (find-symbol name)))))
  204.  
  205. (defun prompt-complete-buffer (word)
  206.   (delete-if-not #'(lambda (b)
  207.              (string-head-eq b word))
  208.          (mapcar 'buffer-name buffer-list)))
  209.  
  210. (defun prompt-validate-buffer (name)
  211.   (if (equal name "")
  212.       t
  213.     (get-buffer name)))
  214.  
  215. (defvar prompt-file-exclude '"\\.(o|jlc|x)$|~$|^#.*#$"
  216.   "A regexp, if it matches the file being considered for completion, the file
  217. is rejected.")
  218.  
  219. ;; Don't want .info files (WB icons) on Amigas, everywhere else they're okay
  220. ;; though.
  221. (when (amiga-p)
  222.   (setq prompt-file-exclude (concat prompt-file-exclude "|\\.info$")))
  223.  
  224. ;; Ignore the `.' and `..' directory entries in UNIX
  225. (when (unix-p)
  226.   (setq prompt-file-exclude (concat prompt-file-exclude "|^\\.(\\.|)$")))
  227.  
  228. (defun prompt-complete-filename (word)
  229.   (setq word (expand-file-name word))
  230.   (let*
  231.       ((path (file-name-directory word))
  232.        (file (file-name-nondirectory word))
  233.        (files (directory-files path)))
  234.     (mapcar #'(lambda (x &aux y) 
  235.         (when (file-directory-p (setq y (concat path x)))
  236.           (setq y (concat y ?/)))
  237.         y)
  238.         (delete-if #'(lambda (f)
  239.                (or (not (string-head-eq f file))
  240.                    (regexp-match prompt-file-exclude f)))
  241.                files))))
  242.  
  243. (defun prompt-validate-filename (name)
  244.   (file-exists-p name))
  245.  
  246. (defun prompt-complete-directory (word)
  247.   (setq word (expand-file-name word))
  248.   (let
  249.       ((path (file-name-directory word))
  250.        (file (file-name-nondirectory word)))
  251.     (delq 'nil
  252.       (mapcar #'(lambda (x)
  253.               (when (file-directory-p (concat path x))
  254.             (concat path x ?/)))
  255.           (delete-if #'(lambda (f)
  256.                  (not (string-head-eq f file)))
  257.                  (directory-files path))))))
  258.  
  259. (defun prompt-validate-directory (name)
  260.   (file-directory-p name))
  261.  
  262. (defun prompt-complete-from-list (word)
  263.   (let
  264.       ((src prompt-list)
  265.        (dst ()))
  266.     (while src
  267.       (when (string-head-eq (car src) word)
  268.     (setq dst (cons (car src) dst)))
  269.       (setq src (cdr src)))
  270.     dst))
  271.  
  272. (defun prompt-validate-from-list (name)
  273.   (when (member name prompt-list)
  274.     t))
  275.  
  276.  
  277. ;; High-level entrypoints; prompt for a specific type of object
  278.  
  279. (defun prompt-for-file (&optional prompt existing start)
  280.   "Prompt for a file, if EXISTING is t only files which exist are
  281. allowed to be entered."
  282.   (unless (stringp prompt)
  283.     (setq prompt "Enter filename:"))
  284.   (unless (stringp start)
  285.     (setq start (file-name-directory (buffer-file-name))))
  286.   (if (and (amiga-p) amiga-use-file-req-p)
  287.       (if existing
  288.       (let
  289.           (file)
  290.         (while (null file)
  291.           (unless (setq file (file-req prompt start))
  292.         (return))
  293.           (unless (file-exists-p file)
  294.         (beep)
  295.         (req "That file doesn't exist!" "Continue")
  296.         (setq file nil)))
  297.         file)
  298.     (file-req prompt start))
  299.     (let*
  300.     ((prompt-completion-function 'prompt-complete-filename)
  301.      (prompt-validate-function (if existing
  302.                        'prompt-validate-filename
  303.                      nil))
  304.      (prompt-word-regexps prompt-def-regexps)
  305.      (str (prompt2 prompt start)))
  306.       (when str
  307.     (expand-file-name str)))))
  308.  
  309. (defun prompt-for-directory (&optional prompt existing start)
  310.   "Prompt for a directory, if EXISTING is t only files which exist are
  311. allowed to be entered."
  312.   (unless (stringp prompt)
  313.     (setq prompt "Enter filename:"))
  314.   (unless (stringp start)
  315.     (setq start (file-name-directory (buffer-file-name))))
  316.   (let*
  317.       ((prompt-completion-function 'prompt-complete-directory)
  318.        (prompt-validate-function (if existing
  319.                      'prompt-validate-directory
  320.                    nil))
  321.        (prompt-word-regexps prompt-def-regexps)
  322.        (str (prompt2 prompt start)))
  323.     (when str
  324.       (expand-file-name str))))
  325.  
  326. (defun prompt-for-buffer (&optional prompt existing default)
  327.   "Prompt for a buffer, if EXISTING is t the buffer selected must exist,
  328. otherwise if EXISTING is nil the buffer will be created if it doesn't
  329. exist already. DEFAULT is the value to return if the user enters the null
  330. string, if nil the current buffer is returned."
  331.   (unless (stringp prompt)
  332.     (setq prompt "Enter buffer name:"))
  333.   (let*
  334.       ((prompt-completion-function 'prompt-complete-buffer)
  335.        (prompt-validate-function (if existing
  336.                      'prompt-validate-buffer
  337.                    nil))
  338.        (prompt-word-regexps prompt-def-regexps)
  339.        (buf (prompt2 prompt)))
  340.     (if (equal buf "")
  341.     (or default (current-buffer))
  342.       (unless (get-buffer buf)
  343.     (when (not existing)
  344.       (open-buffer buf))))))
  345.  
  346. ;; borrowed from lisp-mode.jl
  347. (defvar symbol-word-regexps ["[^][()?'\"#; ]" "[][()?'\"#; ]|$"])
  348.  
  349. (defun prompt-for-symbol (&optional prompt prompt-symbol-predicate)
  350.   "Prompt for an existing symbol. If PROMPT-SYMBOL-PREDICATE is given the
  351. symbol must agree with it."
  352.   (unless (stringp prompt)
  353.     (setq prompt "Enter name of symbol:"))
  354.   (let
  355.       ((prompt-completion-function 'prompt-complete-symbol)
  356.        (prompt-validate-function 'prompt-validate-symbol)
  357.        (prompt-word-regexps symbol-word-regexps))
  358.     (intern (prompt2 prompt))))
  359.  
  360. (defun prompt-for-lisp (&optional prompt)
  361.   "Prompt for a lisp object."
  362.   (unless (stringp prompt)
  363.     (setq prompt "Enter a Lisp object:"))
  364.   (let
  365.       ((prompt-completion-function 'prompt-complete-symbol)
  366.        (prompt-validate-function nil)
  367.        (prompt-word-regexps symbol-word-regexps)
  368.        (prompt-symbol-predicate nil))
  369.     (read-from-string (prompt2 prompt))))
  370.  
  371. (defun prompt-for-function (&optional prompt)
  372.   "Prompt for a function."
  373.   (prompt-for-symbol (or prompt "Enter name of function:")
  374.              'fboundp))
  375.  
  376. (defun prompt-for-variable (&optional prompt)
  377.   "Prompt for a variable."
  378.   (prompt-for-symbol (or prompt "Enter name of variable:")
  379.              'boundp))
  380.  
  381. (defun prompt-for-command (&optional prompt)
  382.   "Prompt for a command."
  383.   (prompt-for-symbol (or prompt "Enter name of command:")
  384.              'commandp))
  385.  
  386. (defun prompt-from-list (prompt-list prompt &optional start)
  387.   "Return a selected choice from the list of options (strings) PROMPT-LIST.
  388. PROMPT is the title displayed, START the starting choice."
  389.   (let
  390.       ((prompt-completion-function 'prompt-complete-from-list)
  391.        (prompt-validate-function 'prompt-validate-from-list)
  392.        (prompt-word-regexps prompt-def-regexps))
  393.   (prompt2 prompt start)))
  394.  
  395. (defun prompt-for-string (&optional prompt start)
  396.   (prompt (or prompt "Enter string: " start)))
  397.  
  398. (defun prompt-for-number (&optional prompt)
  399.   (let
  400.       (num)
  401.     (while (not (numberp num))
  402.       (setq num (read-from-string (prompt (or prompt "Enter number: ")))))
  403.     num))
  404.